proto <- function (. = parent.env(envir), expr = {}, envir = 
		new.env(parent = parent.frame()), ..., funEnvir = envir) {
    parent.env(envir) <- .
    as.proto.environment(envir)  # must do this before eval(...)
    # moved eval after for so that ... always done first
    # eval(substitute(eval(quote({ expr }))), envir)
    dots <- list(...); names <- names(dots)
    for (i in seq(length = length(dots))) { 
      assign(names[i], dots[[i]], env = envir)
      if (!identical(funEnvir, FALSE) && is.function(dots[[i]])) 
        environment(envir[[names[i]]]) <- funEnvir
    }
    eval(substitute(eval(quote({ expr }))), envir)
    if (length(dots)) as.proto.environment(envir) else envir
}

as.proto <- function(x, ...) UseMethod("as.proto")
as.proto.environment <- function(x, ...) {
	assign(".that", x, env = x)
	assign(".super", parent.env(x), env = x)
	structure(x, class = c("proto", "environment"))
}
as.proto.proto <- function(x, ...) x
as.proto.list <- function(x, envir, parent, all.names = FALSE, ..., 
	funEnvir = envir, SELECT = function(x) TRUE) {
       if (missing(envir)) {
		if (missing(parent)) parent <- parent.frame()
		envir <- if (is.proto(parent)) 
			parent$proto(...) 
		else 
			proto(parent, ...)
       }
       for(s in names(x))
          if (SELECT(x[[s]])) {
             assign(s, x[[s]], env = envir)
             if (is.function(x[[s]]) && !identical(funEnvir, FALSE)) 
		environment(envir[[s]]) <- funEnvir
          }
       if (!missing(parent)) parent.env(envir) <- parent
       as.proto.environment(envir)  # force refresh of .that and .super
}

"$.proto" <- function(this, x) {
   inh <- substr(x,1,2) != ".."
   p <- parent.frame()
   is.function <- is.function(get(x, env = this, inherits = inh))
   is.that <- match(deparse(substitute(this)), c(".that",".super"), nomatch=0)
   s <- if (is.function && !is.that)
         substitute(structure(function(...) get(x, env = this, inherits = inh)(this, ...), class = "protoGetter"))
   else
         substitute(get(x, env = this, inherits = inh))
   res <- eval(s, list(inh = inh), p)
   if (is.function && !is.that) environment(res) <- p
   if (is.proto(res) && !exists(x, env = this, inherits = FALSE)) {
     # Add prototype layers for the child ("x") to match
     # the inheritance chain of the parent ("this")
     # so "a$b$c <- something" works better.

     # look back to find where "res" resides
     tmpenvs <- list(this)
     while (!exists(x, env = tmpenvs[[1]], inherits = FALSE)) {
       tmpenvs <- c(parent.env(tmpenvs[[1]]), tmpenvs)
     }
     # trace forward and add the empty protos for the children
     for (i in seq(from = 1, len = length(tmpenvs) - 1)) {
       assign(x, tmpenvs[[i]][[x]]$proto(), envir =  tmpenvs[[i + 1]])
     }
     res <- tmpenvs[[i+1]][[x]]
   }
   res
}

print.protoGetter <- function(x, ...) {
  cat("proto function evaluator: ")
  print(unclass(x))
  cat("Evaluated as: ")
  print(eval(body(x)[[1]]))
}

"$<-.proto" <- function(this,s,value) { 
    if (s == ".super") parent.env(this) <- value
    if (is.function(value))  environment(value) <- this
	this[[as.character(substitute(s))]] <- value
	this
}

"$<-.proto" <- function(this,s,value) { 
    if (s == ".super") parent.env(this) <- value
    if (is.function(value)) {
      e1 <- e2 <- environment(value)
      while (!identical(e1, .GlobalEnv)){
        e2 <- e1
        e1 <- parent.env(e)
      }
      environment(e2) <- this
    }
	this[[as.character(substitute(s))]] <- value
	this
}


is.proto <- function(x) inherits(x, "proto")
isnot.function <- function(x) ! is.function(x)

#with.default seems to work just as well
#with.proto <- function(data, expr, ...)
#   eval.parent(substitute(eval(substitute(expr), data)))

ls.proto <- function(x, includeParents = TRUE, ...) {
  res <- ls(envir = x, ...)
  if (includeParents) {
    while (is.proto(parent.env(x))) {
      res <- c(res, ls(envir = parent.env(x), ...))
      x <- parent.env(x)
    }
  }
  unique(res)
}

with.proto <- function(data, expr, ...) {
  # find protos nested under protos that are missing inheritance chains
  upstreamProtos <- {
    x <- data
    res <- NULL
    while (is.proto(parent.env(x))) {
      p <- ls(envir = parent.env(x), ...)
      p <- p[sapply(p,
             function(z) is.proto(get(z, env = parent.env(x), inherits = FALSE)))]
      res <- c(res, p)
      x <- parent.env(x)
    }
    unique(res)
  }
  localProtos <- ls(env = data)
  if (length(localProtos) > 0)
    localProtos <- localProtos[sapply(localProtos,
                                      function(x) is.proto(get(x, env = data, inherits = FALSE)))]
  missingProtos <- setdiff(upstreamProtos, localProtos)
  # fill in the missing protos 
  for (x in missingProtos)
    eval.parent(substitute(data$z <- data$z, list(data = substitute(data), z = x)))
  eval(substitute(expr), data, enclos = parent.frame())
}


str.proto <- function(object, max.level = NA, nest.lev = 0,
    indent.str = paste(rep.int(" ", max(0, nest.lev + 1)), collapse = ".."),
    comp.str = "$ ", envir = baseenv(), ...) {
  cat("proto environment\n")
  if (is.na(max.level) || nest.lev < max.level) {
    nam.ob <- ls(object)
    le <- length(nam.ob)
    if ((le) == 0) {nam.ob = " "; cat(indent.str, "empty\n")}
    max.ncnam <- max(nchar(nam.ob, type = "w"))
    nam.fmt <- format(nam.ob, width = max.ncnam, justify = "left")
    for (i in seq(len=le)) {
      cat(indent.str, comp.str, nam.fmt[i], ":", sep = "")
       envir <- if (typeof(object[[nam.ob[i]]]) == "promise") {
         structure(object, nam = as.name(nam.ob[i]))
       }
      str(object[[nam.ob[i]]], nest.lev = nest.lev + 1, indent.str = paste(indent.str, ".."), envir = envir, ...)
    }
  }
  if (is.proto(parent.env(object))) {
    cat(indent.str, "inherits from: ")
    str(parent.env(object), nest.lev = nest.lev)
  }
}


original <- proto(a = 1, level2 = proto(x = "orig", b = function(x) 33))
descendent <- original$proto(c = 5)
descendent$level2$x
descendent$level2$x <- "new"
descendent$level2$y <- "another"
descendent$level2$z <- "yet another"
original$level2$x
str(descendent)

original <- proto(a = 1, level2 = proto(x = "orig", b = function(x) 33))
descendent <- original$proto(c = 5)
secondgen <- descendent$proto()
secondgen$level2$x <- "new"
secondgen$level2$x
descendent$level2$x
original$level2$x

original <- proto(a = 1, level2 = proto(x = "orig", b = function(x) 33))
descendent <- original$proto(c = 5)
secondgen <- descendent$proto()
descendent$level2$x <- "new"
secondgen$level2$x
descendent$level2$x
original$level2$x

descendent2 <- original$proto(c = 5)
with(descendent2$level2, x <- "new") 
descendent2$level2$x

original <- proto(a = 1, level2 = proto(x = "orig", b = function(x) 33))
descendent2 <- original$proto(c = 5)
with(descendent2, level2$x <- "new")
descendent2$level2$x
original$level2$x

original <- proto(a = 1, level2 = proto(x = "orig", b = function(x) 33, level3 = proto(z = 44)))
descendent <- original$proto()
descendent$level2$level3$z <- 11
descendent$level2$level3$z
original$level2$level3$z

